unit uDBConnPool;

interface

uses
  SysUtils, Classes, DB, ADODB, Windows, uDZSysUtils, uDZPersistent, uDZSerializer,
  uDZLinkList, uDZTrace, uDZDataSetSerializer, uDZConfig, uDZDatabase,
  uCxtConst, uAppLog, uAppConfig, uCxtTypes;

type
  TDBConnection = class(TDzDblLinkListNode)
  private
    fConnection: TADOConnection;
    fQuery: TADOQuery;
    fStoredProc: TADOStoredProc;
    fClassReader: IDzClassReader;
    function GetConnectionString: WideString;
    procedure SetConnectionString(const Value: WideString);
  protected
    procedure Connect(out ErrCode: Integer; out ErrMsg: WideString);
  public
    constructor Create(LinkList: TDzDblLinkList); override;
    destructor Destroy; override;

    procedure ExecSQL(const Command: WideString; out ErrCode: Integer;
      out ErrMsg: WideString; NoRecord: Boolean = False;
      Affected: PInteger = nil);
      
    procedure ExecStoredProc(out ErrCode: Integer; out ErrMsg: WideString;
      NoRecord: Boolean = False);

    function ExtractQuery: TADOQuery;
    function ExtractStoredProc: TADOStoredProc;
    property Connection: TADOConnection read fConnection;
    property Query: TADOQuery read fQuery;
    property StoredProc: TADOStoredProc read fStoredProc;
    property ClassReader: IDzClassReader read fClassReader;
    property ConnectionString: WideString read GetConnectionString
      write SetConnectionString;
  end;

  TConnectionPool = class
  private
    fConnList: TDzDblLinkList;
    fPoolSize: Integer;
    fSemaphore: THandle;
  public
    constructor Create;
    destructor Destroy; override;
    function GetConnection: TDBConnection;
    procedure ReleaseConnection(Conn: TDBConnection);
  end;

procedure ExecCommand(const Command: WideString; out ErrCode: Integer;
  out ErrMsg: WideString; Affected: PInteger = nil);
  
procedure GetSingleField(const Command: WideString; const Name: string;
  out Value: Variant; out ErrCode: Integer; out ErrMsg: WideString);

procedure GetRow(const Command: WideString; Model: TDzPersistent;
  out ErrCode: Integer; out ErrMsg: WideString);

procedure GetPagedRecords(Conn: TDBConnection; PageIndex, PageSize: Integer;
  const IndexField, SelFields, From, Condition, OrderBy: WideString;
  out TtlRec, ErrCode: Integer; out ErrMsg: WideString);
  
//read-only
var
  ConnPool: TConnectionPool;

implementation

procedure ExecCommand(const Command: WideString; out ErrCode: Integer;
  out ErrMsg: WideString; Affected: PInteger);
var
  Conn: TDBConnection;
  num: Integer;
begin
  Conn := ConnPool.GetConnection;
  if not Assigned(Conn) then
  begin
    ErrCode := CXT_E_SYSTEM_BUSY;
    ErrMsg := SSystemBusy;
    Exit;
  end;
  if Affected = nil then Affected := @num;
  try
    Conn.ExecSQL(Command, ErrCode, ErrMsg, True, Affected);
    if (ErrCode = 0) and (affected^ = 0) and (affected <> @num) then
    begin
      ErrCode := CXT_E_NO_DATA;
      ErrMsg := '';
    end;
  finally
    ConnPool.ReleaseConnection(Conn);
  end;
end;

procedure GetSingleField(const Command: WideString; const Name: string;
  out Value: Variant; out ErrCode: Integer; out ErrMsg: WideString);
var
  Conn: TDBConnection;
begin
  Conn := ConnPool.GetConnection;
  if not Assigned(Conn) then
  begin
    ErrCode := CXT_E_SYSTEM_BUSY;
    ErrMsg := SSystemBusy;
    Exit;
  end;
  try
    Conn.ExecSQL(Command, ErrCode, ErrMsg);
    if ErrCode <> 0 then Exit;
    if Conn.Query.IsEmpty then ErrCode := CXT_E_NO_DATA
    else begin
      if Name = '' then Value := Conn.Query.Fields[0].Value
      else Value := Conn.Query.FieldByName(Name).Value;
    end;
  finally
    ConnPool.ReleaseConnection(Conn);
  end;
end;

procedure GetRow(const Command: WideString; Model: TDzPersistent;
  out ErrCode: Integer; out ErrMsg: WideString);
var
  Conn: TDBConnection;
begin
  Conn := ConnPool.GetConnection;
  if not Assigned(Conn) then
  begin
    ErrCode := CXT_E_SYSTEM_BUSY;
    ErrMsg := SSystemBusy;
    Exit;
  end;

  with Conn do
  try
    ExecSQL(Command, ErrCode, ErrMsg);
    if ErrCode <> 0 then Exit;
    if Query.IsEmpty then
    begin
      ErrCode := CXT_E_NO_DATA;
      ErrMsg := SUnknownError;
    end
    else try
      Model.Load(ClassReader);
    except
      ErrCode := CXT_E_SERIALIZING;
      ErrMsg := SCodecError;
    end;
  finally
    ConnPool.ReleaseConnection(Conn);
  end;
end;

procedure GetPagedRecords(Conn: TDBConnection; PageIndex, PageSize: Integer;
  const IndexField, SelFields, From, Condition, OrderBy: WideString;
  out TtlRec, ErrCode: Integer; out ErrMsg: WideString);
begin
  with Conn.StoredProc, Conn.StoredProc.Parameters do
  begin
    Clear;
    ProcedureName := '[Cxt_56888_net].[dbo].[GetPagedRecord]';
    CreateParameter('pageIndex', ftInteger, pdInput, 4, PageIndex);
    CreateParameter('PageSize', ftInteger, pdInput, 4, PageSize);
    CreateParameter('indexField', ftWideString, pdInput, 256, IndexField);
    CreateParameter('selFields', ftWideString, pdInput, 1024, SelFields);
    CreateParameter('fromObjects', ftWideString, pdInput, 1024, From);
    CreateParameter('condition', ftWideString, pdInput, 2048, Condition);
    CreateParameter('OrderBy', ftWideString, pdInput, 1024, OrderBy);
    CreateParameter('totalRecords', ftInteger, pdOutput, 4, TtlRec);
    Conn.ExecStoredProc(ErrCode, ErrMsg, False);
    if ErrCode = 0 then TtlRec := ParamValues['totalRecords'];
  end;
end;

{ TDBConnection }

procedure TDBConnection.Connect(out ErrCode: Integer; out ErrMsg: WideString);
begin
  try
    fConnection.Connected := True;
    ErrCode := CXT_E_SUCCESS;
    ErrMsg := '';
  except
    on E: Exception do
    begin
      LogException('ADOConnection.Open', E);
      ErrCode := CXT_E_DATABASE_UNREACHABLE;
      ErrMsg := SCannotConnectDB;
    end;
  end;
end;

constructor TDBConnection.Create(LinkList: TDzDblLinkList);
begin
  fConnection := TADOConnection.Create(nil);
  fConnection.LoginPrompt := False;
  fQuery := TADOQuery.Create(nil);
  fQuery.Connection := fConnection;
  fStoredProc := TADOStoredProc.Create(nil);
  fStoredProc.Connection := fConnection;
  fClassReader := TDzDataSetClassReader.Create(fQuery);
  inherited;
end;

destructor TDBConnection.Destroy;
begin
  fQuery.Free;
  fStoredProc.Free;
  fConnection.Free;
  inherited;
end;

procedure TDBConnection.ExecSQL(const Command: WideString; out ErrCode: Integer;
  out ErrMsg: WideString; NoRecord: Boolean; Affected: PInteger);
begin
  Connect(ErrCode, ErrMsg);
  if ErrCode <> 0 then Exit;
  if Command <> '' then fQuery.SQL.Text := Command;
  while True do
  begin
    try
      if NoRecord then
      begin
        if Affected = nil then fQuery.ExecSQL
        else Affected^ := fQuery.ExecSQL;
      end
      else fQuery.Open;
      ErrCode := CXT_E_SUCCESS;
      ErrMsg := '';
      Break;
    except
      on E: Exception do
      begin
        LogException('TADOQuery.Open', E);
        if CanReConnect(E.Message) then 
        begin
          fConnection.Connected := False;
          Connect(ErrCode, ErrMsg);
          if ErrCode <> 0 then Break;
        end
        else begin
          ErrCode := CXT_E_DBENGINE;
          ErrMsg := SDatabaseError;
          Break;
        end;
      end;
    end;
  end;
end;

procedure TDBConnection.ExecStoredProc(out ErrCode: Integer;
  out ErrMsg: WideString; NoRecord: Boolean);
begin
  Connect(ErrCode, ErrMsg);
  if ErrCode <> 0 then Exit;
  while True do
  begin
    try
      if NoRecord then fStoredProc.ExecProc
      else fStoredProc.Open;
      ErrCode := 0;
      ErrMsg := '';
      Break;
    except
      on E: Exception do
      begin
        LogException('TADOStoredProc.Open', E);
        if CanReConnect(E.Message) then
        begin
          fConnection.Connected := False;
          Connect(ErrCode, ErrMsg);
          if ErrCode <> 0 then Break;
        end
        else begin
          ErrCode := CXT_E_DBENGINE;
          ErrMsg := SDatabaseError;
          Break;
        end;
      end;
    end;
  end;
end;

function TDBConnection.ExtractQuery: TADOQuery;
var
  Qry: TADOQuery;
begin
  Qry := TADOQuery.Create(nil);
  Qry.Connection := fConnection;
  Qry.CommandTimeout := fQuery.CommandTimeout;
  Result := fQuery;
  fQuery := Qry;
end;

function TDBConnection.ExtractStoredProc: TADOStoredProc;
var
  Proc: TADOStoredProc;
begin
  Proc := TADOStoredProc.Create(nil);
  Proc.Connection := fConnection;
  Proc.CommandTimeout := fStoredProc.CommandTimeout;
  Result := fStoredProc;
  fStoredProc := Proc;
end;

function TDBConnection.GetConnectionString: WideString;
begin
  Result := fConnection.ConnectionString;
end;

procedure TDBConnection.SetConnectionString(const Value: WideString);
begin
  fConnection.ConnectionString := Value;
end;

{ TConnectionPool }

constructor TConnectionPool.Create;
begin
  fConnList := TDzDblLinkList.Create(TDBConnection, lmStack, True);
  fSemaphore := Windows.CreateSemaphore(nil, 0, $7fffffff, nil);
end;

destructor TConnectionPool.Destroy;
begin
  fConnList.Free;
  Windows.CloseHandle(fSemaphore);
  inherited;
end;

function TConnectionPool.GetConnection: TDBConnection;
begin
  fConnList.Lock;
  try
    Result := TDBConnection(fConnList.Pop);
    if Result <> nil then Exit;
    if fPoolSize < AppConfig.DBConnectionPoolSize then
    begin
      InterlockedIncrement(fPoolSize);
      Result := TDBConnection.Create(nil);
      with TDzMSSQLADOCP(AppConfig.ConnParam) do
      begin
        Result.ConnectionString := ConnString;
        Result.Connection.ConnectionTimeout := ConnectionTimeout;
        Result.Query.CommandTimeout := CommandTimeout;
        Result.StoredProc.CommandTimeout := CommandTimeout;
      end;
      Exit;
    end;
    fConnList.Release;
    WaitForSingleObject(fSemaphore, INFINITE);
    fConnList.Lock;
    Result := TDBConnection(fConnList.Pop);
  finally
    fConnList.Release;
  end;
end;

procedure TConnectionPool.ReleaseConnection(Conn: TDBConnection);
begin
  Conn.StoredProc.Close;
  Conn.Query.Close;
  fConnList.LockPush(Conn);
  Windows.ReleaseSemaphore(fSemaphore, 1, nil);
end;

initialization
  ConnPool := TConnectionPool.Create;

finalization
  ConnPool.Free;
  
end.
